home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / read.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  14.5 KB  |  695 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    read.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <stdio.h>
  35. #include <ctype.h>
  36. #ifdef sun
  37. #include <floatingpoint.h>
  38. #endif
  39.  
  40. #include "read.h"
  41.  
  42. #include "bytestring.h"
  43. #include "character.h"
  44. #include "dylan_lexer.h"
  45. #include "dylan.tab.h"
  46. #include "error.h"
  47. #include "file.h"
  48. #include "list.h"
  49. #include "number.h"
  50. #include "parse.h"
  51. #include "prim.h"
  52. #include "symbol.h"
  53. #include "vector.h"
  54.  
  55. extern FILE *yyin;
  56. extern Object yylval;
  57.  
  58. /* local function prototypes */
  59.  
  60. static Object infix_read_object (FILE * fp);
  61. static Object infix_decode_token (int yychar, FILE * fp);
  62.  
  63. static Object read_wrapper (Object stream);
  64. static Object read_char (Object stream);
  65.  
  66. static Object read_list (FILE * fp);
  67. static Object read_string (FILE * fp);
  68. static Object read_quote (FILE * fp);
  69. static Object read_vector (FILE * fp);
  70. static Object read_number (FILE * fp);
  71. static Object read_symbol (FILE * fp);
  72. static Object read_character (FILE * fp);
  73. static Object read_quasiquote (FILE * fp);
  74. static Object read_unquote (FILE * fp);
  75. static Object read_unquote_splicing (FILE * fp);
  76.  
  77. static void skip_whitespace_comments (FILE * fp);
  78. static char peek_char (FILE * fp);
  79. static int match_chars (FILE * fp, char *str);
  80.  
  81. /* primitives */
  82.  
  83. static struct primitive read_prims[] =
  84. {
  85.     {"%read", prim_0_1, read_wrapper},
  86.     {"%read-char", prim_0_1, read_char},
  87. };
  88.  
  89. /* function definitions */
  90.  
  91. void
  92. init_read_prims (void)
  93. {
  94.     int num;
  95.  
  96.     num = sizeof (read_prims) / sizeof (struct primitive);
  97.  
  98.     init_prims (num, read_prims);
  99. }
  100.  
  101. static Object
  102. infix_read_object (FILE * fp)
  103. {
  104.     int yychar;
  105.     int old_load_file_context = load_file_context;
  106.  
  107.     load_file_context = 1;
  108.  
  109.     if (yyin != fp) {
  110.     reset_parser (fp);
  111.     }
  112.     if ((yychar = yylex ()) < 0)
  113.     yychar = 0;
  114.  
  115.     load_file_context = old_load_file_context;
  116.     return infix_decode_token (yychar, fp);
  117. }
  118.  
  119. static Object
  120. infix_decode_token (int yychar, FILE * fp)
  121. {
  122.     switch (yychar) {
  123.     case EOF_TOKEN:
  124.     return (eof_object);
  125.     case LITERAL:
  126.     case STRING:
  127.     case HASH_T:
  128.     case HASH_F:
  129.     return (yylval);
  130.     case HASH_BRACKET:
  131.     {
  132.         Object new_list = make_empty_list ();
  133.         Object *new_list_ptr = &new_list;
  134.  
  135.         do {
  136.         if ((yychar = yylex ()) < 0)
  137.             yychar = 0;
  138.         if (yychar == ']')
  139.             return new_list;
  140.  
  141.         *new_list_ptr = cons (infix_decode_token (yychar, fp),
  142.                       make_empty_list ());
  143.         new_list_ptr = &CDR (*new_list_ptr);
  144.  
  145.         if ((yychar = yylex ()) < 0)
  146.             yychar = 0;
  147.         } while (yychar == ',');
  148.  
  149.         if (yychar != ']') {
  150.         return error ("Malformed vector.  Expected a ']'", NULL);
  151.         }
  152.         return make_sov (new_list);
  153.     }            /* case HASH_BRACKET */
  154.     case HASH_PAREN:
  155.     {
  156.         Object new_list = make_empty_list ();
  157.         Object *new_list_ptr = &new_list;
  158.  
  159.         do {
  160.         if ((yychar = yylex ()) < 0)
  161.             yychar = 0;
  162.         if (yychar == ')')
  163.             return new_list;
  164.  
  165.         *new_list_ptr = cons (infix_decode_token (yychar, fp),
  166.                       make_empty_list ());
  167.         new_list_ptr = &CDR (*new_list_ptr);
  168.  
  169.         if ((yychar = yylex ()) < 0)
  170.             yychar = 0;
  171.         } while (yychar == ',');
  172.  
  173.         if (yychar == '.') {
  174.         *new_list_ptr = infix_read_object (fp);
  175.         if ((yychar = yylex ()) < 0)
  176.             yychar = 0;
  177.         }
  178.         if (yychar != ')') {
  179.         return error ("Malformed list.  Expected a ')'", NULL);
  180.         }
  181.         return new_list;
  182.     }            /* case HASH_PAREN */
  183.     case KEYWORD:
  184.     return yylval;
  185.     default:
  186.     return error ("read couldn't find a literal", NULL);
  187.     }
  188. }
  189.  
  190. Object
  191. read_object (FILE * fp)
  192. {
  193.     signed char ch;
  194.  
  195.     if (!classic_syntax) {
  196.     return infix_read_object (fp);
  197.     }
  198.   start_over:
  199.     skip_whitespace_comments (fp);
  200.     ch = getc (fp);
  201.     switch (ch) {
  202.     case EOF:
  203.     return (eof_object);
  204.     case ')':
  205.     error ("read: unexpected ')'", NULL);
  206.     case '(':
  207.     return (read_list (fp));
  208.     case '"':
  209.     return (read_string (fp));
  210.     case '\'':
  211.     return (read_quote (fp));
  212.     case '`':
  213.     return (read_quasiquote (fp));
  214.     case ',':
  215.     if (peek_char (fp) == '@') {
  216.         ch = getc (fp);
  217.         return (read_unquote_splicing (fp));
  218.     } else {
  219.         return (read_unquote (fp));
  220.     }
  221.     case ';':
  222.     while ((ch = getc (fp)) != '\n') {
  223.         if (ch == EOF) {
  224.         return (eof_object);
  225.         }
  226.     }
  227.     goto start_over;
  228.     break;
  229.     case '+':
  230.     case '-':
  231.     if (isdigit (peek_char (fp))) {
  232.         ungetc (ch, fp);
  233.         return (read_number (fp));
  234.     } else {
  235.         ungetc (ch, fp);
  236.         return (read_symbol (fp));
  237.     }
  238.     case '#':
  239.     ch = getc (fp);
  240.     switch (ch) {
  241.     case 'a':
  242.         if (((ch = getc (fp) != 'l') || ((ch = getc (fp)) != 'l')
  243.          || ((ch = getc (fp)) != '-') || ((ch = getc (fp)) != 'k')
  244.          || ((ch = getc (fp)) != 'e') || ((ch = getc (fp)) != 'y')
  245.          || ((ch = getc (fp)) != 's'))) {
  246.         error ("read: regular symbol cannot begin with '#'", NULL);
  247.         }
  248.         return (allkeys_symbol);
  249.  
  250.     case 'v':
  251.         if (((ch = getc (fp)) != 'a') || ((ch = getc (fp)) != 'l')
  252.         || ((ch = getc (fp)) != 'u') || ((ch = getc (fp)) != 'e')
  253.         || ((ch = getc (fp)) != 's')) {
  254.         error ("read: regular symbol cannot begin with '#'", NULL);
  255.         }
  256.         return (hash_values_symbol);
  257.     case 'k':
  258.         if (((ch = getc (fp)) != 'e') || ((ch = getc (fp)) != 'y')) {
  259.         error ("read: regular symbol cannot begin with `#'", NULL);
  260.         }
  261.         return (key_symbol);
  262.     case 'r':
  263.         if (((ch = getc (fp)) != 'e') || ((ch = getc (fp)) != 's')
  264.         || ((ch = getc (fp)) != 't')) {
  265.         error ("read: regular symbol cannot begin with `#'", NULL);
  266.         }
  267.         return (hash_rest_symbol);
  268.     case 'n':
  269.         if (((ch = getc (fp)) != 'e') || ((ch = getc (fp)) != 'x')
  270.         || ((ch = getc (fp)) != 't')) {
  271.         error ("read: regular symbol cannot begin with `#'", NULL);
  272.         }
  273.         return (next_symbol);
  274.     case '(':
  275.         return (read_vector (fp));
  276.     case '\\':
  277.         return (read_character (fp));
  278.     case 't':
  279.         return (true_object);
  280.     case 'f':
  281.         return (false_object);
  282.     case 'x':
  283.     case 'b':
  284.     case 'o':
  285.         error ("read: hex, binary and octal number reading not supported", NULL);
  286.     case '|':
  287.         do {
  288.         ch = getc (fp);
  289.         if (ch == EOF) {
  290.             error ("read: end of file in #| comment", NULL);
  291.         }
  292.         if ((ch == '|') && (peek_char (fp) == '#')) {
  293.             ch = getc (fp);
  294.             goto start_over;
  295.         }
  296.         }
  297.         while (1);
  298.         break;
  299.     default:
  300.         error ("read: unexpected `#'", NULL);
  301.     }
  302.     default:
  303.     if (isdigit (ch)) {
  304.         ungetc (ch, fp);
  305.         return (read_number (fp));
  306.     } else {
  307.         ungetc (ch, fp);
  308.         return (read_symbol (fp));
  309.     }
  310.     }
  311.  
  312. }
  313.  
  314. static Object
  315. read_wrapper (Object stream)
  316. {
  317.     FILE *fp;
  318.  
  319.     if (stream) {
  320.     fp = STREAMFP (stream);
  321.     } else {
  322.     fp = stdin;
  323.     }
  324.     return (read_object (fp));
  325. }
  326.  
  327. static Object
  328. read_char (Object stream)
  329. {
  330.     FILE *fp;
  331.     int ch;
  332.  
  333.     if (stream) {
  334.     fp = STREAMFP (stream);
  335.     } else {
  336.     fp = stdin;
  337.     }
  338.     ch = getc (fp);
  339.     if (ch == EOF) {
  340.     return (eof_object);
  341.     } else {
  342.     return (make_character (ch));
  343.     }
  344. }
  345.  
  346. /* "(" has already been read */
  347. static Object
  348. read_list (FILE * fp)
  349. {
  350.     Object obj, car, cdr;
  351.     char ch;
  352.  
  353.     skip_whitespace_comments (fp);
  354.     ch = getc (fp);
  355.     if (ch == ')')
  356.     return (make_empty_list ());
  357.     if (ch == EOF)
  358.     error ("read: unexpected EOF while reading a list", NULL);
  359.     ungetc (ch, fp);
  360.     car = read_object (fp);
  361.     skip_whitespace_comments (fp);
  362.     ch = getc (fp);
  363.     if (ch == ')') {
  364.     cdr = make_empty_list ();
  365.     } else if (ch == '.') {
  366.     cdr = read_object (fp);
  367.     skip_whitespace_comments (fp);
  368.     ch = getc (fp);
  369.     if (ch != ')') {
  370.         error ("read: malformed list", NULL);
  371.     }
  372.     } else {
  373.     ungetc (ch, fp);
  374.     cdr = read_list (fp);
  375.     }
  376.  
  377.     return (cons (car, cdr));
  378. }
  379.  
  380. /* '"' has already been read */
  381. static Object
  382. read_string (FILE * fp)
  383. {
  384.     char ch, buf[MAX_STRING_SIZE];
  385.     int i;
  386.  
  387.     i = 0;
  388.     while ((ch = getc (fp)) != '"') {
  389.     if (i > MAX_STRING_SIZE) {
  390.         error ("read: string to long for reader", NULL);
  391.     }
  392.     if (ch == '\\') {
  393.         ch = getc (fp);
  394.     }
  395.     buf[i++] = ch;
  396.     }
  397.     buf[i] = '\0';
  398.     return (make_byte_string (buf));
  399. }
  400.  
  401. /* "'" has been read */
  402. static Object
  403. read_quote (FILE * fp)
  404. {
  405.     Object obj;
  406.  
  407.     obj = read_object (fp);
  408.     return (cons (quote_symbol, cons (obj, make_empty_list ())));
  409. }
  410.  
  411. /* "#(" has been read */
  412. static Object
  413. read_vector (FILE * fp)
  414. {
  415.     Object obj;
  416.  
  417.     obj = read_list (fp);
  418.     return (make_sov (obj));
  419. }
  420.  
  421. /* nothing has been read */
  422. static Object
  423. read_number (FILE * fp)
  424. {
  425.     char ch, buf[MAX_NUMBER_SIZE];
  426.     int i, is_float, is_negative;
  427.  
  428.     i = 0;
  429.     is_negative = is_float = 0;
  430.     ch = getc (fp);
  431.     if (ch == '+') {
  432.     ch = getc (fp);
  433.     } else if (ch == '-') {
  434.     is_negative = 1;
  435.     ch = getc (fp);
  436.     }
  437.     do {
  438.     if (i > MAX_NUMBER_SIZE) {
  439.         error ("read: number too long for reader", NULL);
  440.     }
  441.     if (ch == '.') {
  442.         is_float = 1;
  443.     }
  444.     buf[i++] = ch;
  445.     }
  446.     while (isdigit (ch = getc (fp)) || (ch == '.'));
  447.     ungetc (ch, fp);
  448.     buf[i] = '\0';
  449.     if (is_float) {
  450.     double d;
  451.  
  452.     d = strtod (buf, NULL);
  453.     if (is_negative) {
  454.         d = -d;
  455.     }
  456.     return (make_dfloat (d));
  457.     } else {
  458. #ifdef BIG_INTEGERS
  459.     if (i >= 10) {
  460.         return make_big_integer_str (buf, 10);
  461.     } else {
  462.         i = atoi (buf);
  463.         if (is_negative)
  464.         i = -i;
  465.         return make_integer (i);
  466.     }
  467. #else
  468.     int i;
  469.  
  470.     i = atoi (buf);
  471.     if (is_negative) {
  472.         i = -i;
  473.     }
  474.     return (make_integer (i));
  475. #endif
  476.     }
  477. }
  478.  
  479. /* nothing has been read */
  480. static Object
  481. read_symbol (FILE * fp)
  482. {
  483.     signed char ch, buf[MAX_SYMBOL_SIZE];
  484.     int i;
  485.  
  486.     i = 0;
  487.     while ((!isspace (ch = getc (fp)))
  488.        && (ch != '(')
  489.        && (ch != ')')
  490.        && (ch != '#')
  491.        && (ch != '\'')
  492.        && (ch != '`')) {
  493.     if (ch == EOF) {
  494.         return (eof_object);
  495.     }
  496.     buf[i++] = ch;
  497.     }
  498.     ungetc (ch, fp);
  499.     buf[i] = '\0';
  500.     if (buf[i - 1] == ':') {
  501.     return (make_keyword ((char *) &buf));
  502.     } else {
  503.     return (make_symbol ((char *) &buf));
  504.     }
  505. }
  506.  
  507. /* "#\" has been read */
  508. /*
  509.  * Really this is broken.  It only ignores case on the first char
  510.  * of each symbolic character name.
  511.  */
  512. static Object
  513. read_character (FILE * fp)
  514. {
  515.     char ch;
  516.  
  517.     ch = getc (fp);
  518.     switch (ch) {
  519.     case 'n':            /* maybe `newline' */
  520.     case 'N':
  521.     if (peek_char (fp) == 'e') {
  522.         if (!match_chars (fp, "ewline")) {
  523.         error ("read: bad character constant", NULL);
  524.         } else {
  525.         return (make_character ('\n'));
  526.         }
  527.     } else {
  528.         return (make_character ('n'));
  529.     }
  530.     case 's':            /* maybe `space' */
  531.     case 'S':
  532.     if (peek_char (fp) == 'p') {
  533.         if (!match_chars (fp, "pace")) {
  534.         error ("read: bad character constant", NULL);
  535.         } else {
  536.         return (make_character (' '));
  537.         }
  538.     } else {
  539.         return (make_character ('s'));
  540.     }
  541.     case 'r':            /* maybe `rubout' */
  542.     case 'R':
  543.     if (peek_char (fp) == 'u') {
  544.         if (!match_chars (fp, "ubout")) {
  545.         error ("read: bad character constant", NULL);
  546.         } else {
  547.         return (make_character (0x7f));
  548.         }
  549.     } else if (peek_char (fp) == 'e') {
  550.         if (!match_chars (fp, "eturn")) {
  551.         error ("read: bad character constant", NULL);
  552.         } else {
  553.         return (make_character ('\r'));
  554.         }
  555.     } else {
  556.         return (make_character ('r'));
  557.     }
  558.     case 'p':            /* maybe `page' */
  559.     case 'P':
  560.     if (peek_char (fp) == 'a') {
  561.         if (!match_chars (fp, "age")) {
  562.         error ("read: bad character constant", NULL);
  563.         } else {
  564.         return (make_character ('\f'));
  565.         }
  566.     } else {
  567.         return (make_character ('p'));
  568.     }
  569.     case 't':            /* maybe `tab' */
  570.     case 'T':
  571.     if (peek_char (fp) == 'e') {
  572.         if (!match_chars (fp, "ab")) {
  573.         error ("read: bad character constant", NULL);
  574.         } else {
  575.         return (make_character ('\t'));
  576.         }
  577.     } else {
  578.         return (make_character ('t'));
  579.     }
  580.     case 'b':            /* maybe `backspace' */
  581.     case 'B':
  582.     if (peek_char (fp) == 'e') {
  583.         if (!match_chars (fp, "ackspace")) {
  584.         error ("read: bad character constant", NULL);
  585.         } else {
  586.         return (make_character ('\b'));
  587.         }
  588.     } else {
  589.         return (make_character ('b'));
  590.     }
  591.     case 'l':            /* maybe `linefeed' */
  592.     case 'L':
  593.     if (peek_char (fp) == 'e') {
  594.         if (!match_chars (fp, "inefeed")) {
  595.         error ("read: bad character constant", NULL);
  596.         } else {
  597.         return (make_character ('\n'));
  598.         }
  599.     } else {
  600.         return (make_character ('l'));
  601.     }
  602.     default:
  603.     return (make_character (ch));
  604.     }
  605. }
  606.  
  607. /* "`" has been read */
  608. static Object
  609. read_quasiquote (FILE * fp)
  610. {
  611.     Object quoted_obj, ret;
  612.  
  613.     quoted_obj = read_object (fp);
  614.     ret = cons (quasiquote_symbol, cons (quoted_obj, make_empty_list ()));
  615.     return (ret);
  616. }
  617.  
  618. /* "," has been read */
  619. static Object
  620. read_unquote (FILE * fp)
  621. {
  622.     Object obj, ret;
  623.  
  624.     obj = read_object (fp);
  625.     ret = cons (unquote_symbol, cons (obj, make_empty_list ()));
  626.     return (ret);
  627. }
  628.  
  629. /* ",@" has been read */
  630. static Object
  631. read_unquote_splicing (FILE * fp)
  632. {
  633.     Object obj, ret;
  634.  
  635.     obj = read_object (fp);
  636.     ret = cons (unquote_splicing_symbol, cons (obj, make_empty_list ()));
  637.     return (ret);
  638. }
  639.  
  640. /* utilities */
  641.  
  642. static void
  643. skip_whitespace_comments (FILE * fp)
  644. {
  645.     int ch;
  646.  
  647.   start_over:
  648.     while (isspace (ch = getc (fp))) ;
  649.     if (ch == ';') {
  650.     while ((ch = getc (fp)) != '\n') ;
  651.     goto start_over;
  652.     }
  653.     if ((ch == '#') && (peek_char (fp) == '|')) {
  654.     do {
  655.         ch = getc (fp);
  656.         if (ch == EOF) {
  657.         error ("read: end of file in #| comment", NULL);
  658.         }
  659.         if ((ch == '|') && (peek_char (fp) == '#')) {
  660.         ch = getc (fp);
  661.         goto start_over;
  662.         }
  663.     }
  664.     while (1);
  665.     }
  666.     ungetc (ch, fp);
  667. }
  668.  
  669. static char
  670. peek_char (FILE * fp)
  671. {
  672.     char ch;
  673.  
  674.     ch = getc (fp);
  675.     ungetc (ch, fp);
  676.     return (ch);
  677. }
  678.  
  679. static int
  680. match_chars (FILE * fp, char *str)
  681. {
  682.     int i;
  683.     char ch;
  684.  
  685.     i = 0;
  686.     while (str[i]) {
  687.     ch = getc (fp);
  688.     if (ch != str[i]) {
  689.         return (0);
  690.     }
  691.     i++;
  692.     }
  693.     return (1);
  694. }
  695.